Developer CD Series 1998 August: Tool Chest/Dev.CD Aug 98 TC.toast/Sample Code/Overview/ScreenFKey/ScreenFKEY.p

Text File | 1994-11-18 | 9.2 KB | 284 lines | [TEXT/MPS ]

{ pasmat -q -k -t 2 -: aFKEY6.p FKEY6.p -r -u }

{*#############################################################################################
#
#    Apple Macintosh Developer Technical Support
#
#    FKEY6 : Saves the contents of the main Macintosh screen to a PICT file.
#
#    ScreenFKEY.p
#
#    Copyright © 1989 Apple Computer, Inc.
#    All rights reserved.
#
#    Versions:
#            1.00                     10/89
#
#    Components:
#            ScreenFKEY.p            October 1, 1989
#            ScreenFKEY.a              October 1, 1989
#            ScreenFKEY.make          October 1, 1989
#
#    ScreenFKEY is a basic example on how to spool a PICT file to disk by replacing the
#    bottleneck PutPICProc, it saves the contents of the screen to a file. The FKEY creates
#    ten files Screen 0 through Screen 9; it is necessary to erase or rename old files when
#    the limit is reached.
#
#    This FKEY works in any Macintosh computer and saves the screen regardless of the
#    setting of the screen; to use, it has to be added to the System file using ResEdit.
#
############################################################################################*}



{ The basic strategy is as follows:
  1.- Make sure we can create the file.
  2.- If Color QuickDraw is available then use a color port
      else use a regular B/W port
  3.- Replace the bottleneck procedure for our own putPict procedure
  4.- Open a picture, 3 above guarantees that data will go to disk
  5.- CopyBits the whole screen into itself causing the stuff to go
      to the picture.
  6.- Close the picture
  7.- Finish the PICT file.
  8.- Leave things (QDProcs, port) the way they were.       }

{ Another point of interest is the technique used to provide pseudo
  globals needed for the process to work by tagging the fields to the
  end of the grafport record.           }

UNIT FKEY;

INTERFACE

    USES Types, Quickdraw, Events, Controls, Windows, TextEdit, Dialogs, Fonts,
    Lists, Menus, Resources, Scrap, ToolUtils,
    OSUtils, Files, Devices, DeskBus, DiskInit, Disks, Errors, Memory, Retrace, SegLoad, Serial,
    ShutDown, Slots, Sound, Start, Timer, Packages;

TYPE

{ structure used to mantain some globals that can not be accessed
  in the standard way when QD calls the bottleneck procedure   }

    GDataRec = RECORD
        pHand: PicHandle; { picture being created }
        gRef: INTEGER; { file reference number }
        fileOK: BOOLEAN; { problems flag }
    END;

    { now lets put together a port + our data structure      }
    GportPlus = RECORD
        TRUEPort: CGrafPort;
        GDStuff: GDataRec;
    END;

    GPPtr = ^GportPlus;

{ main procedure for the FKEY }
PROCEDURE PICTOut;

{ PutPICTData replaces the standard bottleneck proc }
PROCEDURE PutPICTData(dataPtr: Ptr;  byteCount: INTEGER);



IMPLEMENTATION

PROCEDURE PutPICTData{(dataPtr: Ptr; byteCount: INTEGER)};

VAR
    longCount: LONGINT; { byte count }
    myPortPlus: GPPtr; { global data pointer }

BEGIN

    GetPort(grafPtr(myPortPlus)); { to access the global data }

    longCount := byteCount;

    IF myPortPlus^.GDStuff.fileOK THEN BEGIN { do this only if file is still OK }

        IF FSWrite(myPortPlus^.GDStuff.gRef, longCount, dataPtr) <> noErr THEN
            { something bad occurred, must delete file }
            myPortPlus^.GDStuff.fileOK := FALSE;

        IF myPortPlus^.GDStuff.pHand <> NIL THEN { if the picture is already open }
            { keep size up to date so QD }
            { can adjust for oddness        }
            myPortPlus^.GDStuff.pHand^^.picSize := myPortPlus^.GDStuff.pHand^^.picSize + longCount;
    END

END;

{ The main procedure of the FKEY.
  This code installs the bottle neck procedure, opens the picture and does all
  the house keeping.
}

PROCEDURE PICTOut;

VAR
    err: OSErr;
    i: INTEGER;
    longCount, longZero: LONGINT;
    myProcs: CQDProcs;
    myOldProcs: QDProcs;

    savePictSizeFrame: Picture;

    nameStr: Str255;
    vrefnum: INTEGER;
    bytesAvail: LONGINT;

    oldPort: grafPtr;
    wPortPlus: GportPlus;
    wPortPlusPtr: GPPtr;
    myDev, aDev: GDHandle;
    pictHand: PicHandle;
    globalRef: INTEGER;

    theWorld: SysEnvRec;

    bitPtr: BitMapPtr;

    { We use this procedure to kill the file if something fails.
    We don't want to leave files laying around, do we? }
    PROCEDURE DeathKiss;
    BEGIN
        IF globalRef <> 0 THEN
            err := FSClose(globalRef);

        { close the file if it is open }
        err := FSDelete(nameStr, vrefnum); { to make sure Delete works }
        SysBeep(1); { Let the world know }
        Exit(PICTOut); { and get out of here! }
    END; {DeathKiss}

BEGIN {PICTOut}

    err := SysEnvirons(1, theWorld); { Lets check if we have what we need }

    { initializing the pointer to port + global stuff}
    wPortPlusPtr := @wPortPlus;

    { Init this variable to help exit procedure clean our stuff when we have to run away. }
    globalRef := 0; { if not zero then a file is open }

    { first we see if it is possible to open file }

    IF GetVInfo(0, @nameStr, vrefnum, bytesAvail) <> noErr THEN
        { get info on default volume }
        DeathKiss; { error, get out of here! }

    { At this point we could check to see if there is room in the volume for the PICT file,
    I chose not to because using a value for the maximun length could probably abort the
    process when there is room for the actual length. I decided that it is better to fail
    when trying to write than kill the saving without reason. }

    { We try to create a file 'Screen x' beginning with 0 up to 9, if ten
    files exist we exit and abort the saving              }
    nameStr := 'Screen 0'; { initial name }
    REPEAT BEGIN
        err := Create(nameStr, vrefnum, 'GAO.', 'PICT');
        IF err <> noErr THEN BEGIN
            IF err = dupFNErr THEN BEGIN { if file already there bump the name }
                nameStr[8] := Chr(Ord(nameStr[8]) + 1);
                IF nameStr[8] = ':' THEN { ten files should be enough }
                    DeathKiss; { can't make more files, get out of here! }
            END
            ELSE
                DeathKiss; { error, get out of here! }
        END
    END UNTIL (err = noErr);

    IF FSOpen(nameStr, vrefnum, globalRef) <> 0 THEN { if error delete }
        DeathKiss; { error, get out of here! }

    { file should be open at this point, so we try to write out the header for the pict file }
    longZero := 0;
    longCount := 4;
    FOR i := 1 TO (532  DIV 4 ) DO BEGIN { init PICT header and then some }
        err := FSWrite(globalRef, longCount, @longZero);
        IF err <> noErr THEN
        DeathKiss {error while file open, get out and kill file }
    END;

    IF SetFPos(globalRef, fsFromStart, 522) <> noErr THEN
        DeathKiss; {error while positioning file, exit }

    GetPort(oldPort); { save current port }

    { init global vars }
    wPortPlus.GDStuff.gRef := globalRef; { for file accesses }
    wPortPlus.GDStuff.pHand := NIL; { no picture when begining }
    wPortPlus.GDStuff.fileOK := TRUE; { we hope }

    IF theWorld.hasColorQD THEN BEGIN
        OpenCport(CGrafPtr(wPortPlusPtr)); { Lets get a color port }
        SetStdCProcs(myProcs); { set its bottleneck procs }
        grafPtr(wPortPlusPtr)^.grafProcs := @myProcs;
        myProcs.putPicProc := @PutPICTData;
        myDev := GetMainDevice; { to get to screen }
        bitPtr := BitMapPtr(myDev^^.gdPMap^)
    END ELSE BEGIN
        Openport(grafPtr(wPortPlusPtr)); { Lets get an old style port }
        SetStdProcs(myOldProcs); { set procs }
        grafPtr(wPortPlusPtr)^.grafProcs := @myOldProcs;
        myOldProcs.putPicProc := @PutPICTData;
        bitPtr := BitMapPtr(@wPortPlusPtr^.TRUEPort.portPixMap)
    END;

    ClipRect(bitPtr^.bounds); { Just in case, make sure clip region is OK. }

    pictHand := OpenPicture(bitPtr^.bounds);

    { On a Macintosh II + color port OpenPicture fails if the heap
    doesn't have at least 1000 bytes free, so we better check
    if we have a valid handle         }

    IF pictHand <> NIL THEN BEGIN
        wPortPlus.GDStuff.pHand := pictHand; { now we have a handle }

        { CopyBits will call our procedure }
        CopyBits(bitPtr^, bitPtr^, bitPtr^.bounds, bitPtr^.bounds, srcCopy, NIL);

        ClosePicture;

    { We need this later to complete file }
        savePictSizeFrame := pictHand^^;

        KillPicture(pictHand) { release all memory }

    END ELSE { no picture saved so we have to kill the file }
        wPortPlus.GDStuff.fileOK := FALSE;

    { Now we proceed to clean up and to restore the port }
    grafPtr(wPortPlusPtr)^.grafProcs := NIL;
    SetPort(oldPort);
    IF theWorld.hasColorQD THEN
        { Lets get rid of the color port }
        CloseCport(CGrafPtr(wPortPlusPtr))
    ELSE
        ClosePort(grafPtr(wPortPlusPtr)); {or get rid of the normal port}

    { after everything is back in good shape we can check if the copybits data
    went to disk a O.K. and if there is a picture at all }

    IF NOT (wPortPlus.GDStuff.fileOK) THEN
        DeathKiss; {error while saving file, exit }

    IF SetFPos(globalRef, fsFromStart, 512) <> noErr THEN
        DeathKiss; {error while positioning file, exit }

    longCount := SizeOf(Picture);
    IF FSWrite(globalRef, longCount, @savePictSizeFrame) <> noErr THEN
        DeathKiss; {error while writing picture size and rect to file, exit }

    IF FSClose(globalRef) <> noErr THEN { now close the file }
        DeathKiss; {error while closing file, exit }

END; {PICTOut}

END. { Unit FKEY }